home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-virtual.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  22.4 KB  |  643 lines
  1. ;;; Virtual folders for VM
  2. ;;; Copyright (C) 1990, 1993, 1994, 1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-virtual)
  19.  
  20. ;; This function builds the virtual message list.
  21. ;;
  22. ;; If the new-messages argument is nil, the message list is
  23. ;; derived from the folders listed in the virtual folder
  24. ;; definition and selected by the various selectors.  The
  25. ;; resulting message list is assigned to vm-message-list.
  26. ;;
  27. ;; If new-messages is non-nil then it is a list of messages to be
  28. ;; tried against the selector parts of the virtual folder
  29. ;; definition.  Matching messages are added to
  30. ;; vm-message-list, instead of replacing it.
  31. ;;
  32. ;; The messages in new-messages must all be in the same real folder.
  33. (defun vm-build-virtual-message-list (new-messages)
  34.   (let ((clauses (cdr vm-virtual-folder-definition))
  35.  
  36.     (message-set (make-vector 311 0))
  37.     (vbuffer (current-buffer))
  38.     (mirrored vm-virtual-mirror)
  39.     (case-fold-search t)
  40.     (tail-cons (vm-last vm-message-list))
  41.     (new-message-list nil)
  42.  
  43.     ;; selectors
  44.     (any 'vm-vs-any)
  45.     (and 'vm-vs-and)
  46.     (or 'vm-vs-or)
  47.     (not 'vm-vs-not)
  48.     (header 'vm-vs-header)
  49.     (label 'vm-vs-label)
  50.     (text 'vm-vs-text)
  51.     (recipient 'vm-vs-recipient)
  52.     (author 'vm-vs-author)
  53.     (subject 'vm-vs-subject)
  54.     (sent-before 'vm-vs-sent-before)
  55.     (sent-after 'vm-vs-sent-after)
  56.     (more-chars-than 'vm-vs-more-chars-than)
  57.     (less-chars-than 'vm-vs-less-chars-than)
  58.     (more-lines-than 'vm-vs-more-lines-than)
  59.     (less-lines-than 'vm-vs-less-lines-than)
  60.     (new 'vm-vs-new)
  61.     (unread 'vm-vs-unread)
  62.     (read 'vm-vs-read)
  63.     (deleted 'vm-vs-deleted)
  64.     (replied 'vm-vs-replied)
  65.     (forwarded 'vm-vs-forwarded)
  66.     (filed 'vm-vs-filed)
  67.     (written 'vm-vs-written)
  68.     (edited 'vm-vs-edited)
  69.     (marked 'vm-vs-marked)
  70.  
  71.     virtual location-vector
  72.     message mp folders folder
  73.     selectors sel-list selector arglist i
  74.     real-buffers-used)
  75.     ;; Since there is at most one virtual message in the folder
  76.     ;; buffer of a virtual folder, the location data vector (and
  77.     ;; the markers in it) of all virtual messages in a virtual
  78.     ;; folder is shared.  We initialize the vector here if it
  79.     ;; hasn't been created already.
  80.     (if vm-message-list
  81.     (setq location-vector (vm-location-data-of (car vm-message-pointer)))
  82.       (setq i 0
  83.         location-vector (make-vector vm-location-data-vector-length nil))
  84.       (while (< i vm-location-data-vector-length)
  85.     (aset location-vector i (vm-marker nil))
  86.     (vm-increment i)))
  87.     ;; To keep track of the messages in a virtual folder to
  88.     ;; prevent duplicates we create and maintain a set that
  89.     ;; contain all the real messages.
  90.     (setq mp vm-message-list)
  91.     (while mp
  92.       (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
  93.           message-set)
  94.       (setq mp (cdr mp)))
  95.     ;; now select the messages
  96.     (save-excursion
  97.       (while clauses
  98.     (setq folders (car (car clauses))
  99.           selectors (cdr (car clauses)))
  100.     (while folders
  101.       (setq folder (car folders))
  102.       (and (stringp folder)
  103.            (setq folder (expand-file-name folder vm-folder-directory)))
  104.       (and (listp folder)
  105.            (setq folder (eval folder)))
  106.       (cond
  107.        ((null folder)
  108.         ;; folder was a s-expr which returned nil
  109.         ;; skip it
  110.         nil )
  111.        ((and (stringp folder) (file-directory-p folder))
  112.         (setq folders (nconc folders
  113.                  (vm-delete-backup-file-names
  114.                   (vm-delete-auto-save-file-names
  115.                    (vm-delete-directory-file-names
  116.                     (directory-files folder t nil)))))))
  117.        ((or (null new-messages)
  118.         ;; If we're assimilating messages into an
  119.         ;; existing virtual folder, only allow selectors
  120.         ;; that would be normally applied to this folder.
  121.         (and (bufferp folder)
  122.              (eq (vm-buffer-of (car new-messages)) folder))
  123.         (and (stringp folder)
  124.              (eq (vm-buffer-of (car new-messages))
  125.              ;; letter bomb protection
  126.              ;; set inhibit-local-variables to t for v18 Emacses
  127.              ;; set enable-local-variables to nil for newer Emacses
  128.              (let ((inhibit-local-variables t)
  129.                    (enable-local-variables nil))
  130.                (find-file-noselect folder)))))
  131.         (set-buffer (or (and (bufferp folder) folder)
  132.                 (vm-get-file-buffer folder)
  133.                 (find-file-noselect folder)))
  134.         (if (eq major-mode 'vm-virtual-mode)
  135.         (setq virtual t
  136.               real-buffers-used
  137.               (append vm-real-buffers real-buffers-used))
  138.           (setq virtual nil)
  139.           (if (not (memq (current-buffer) real-buffers-used))
  140.           (setq real-buffers-used (cons (current-buffer)
  141.                         real-buffers-used)))
  142.           (if (not (eq major-mode 'vm-mode))
  143.           (vm-mode)))
  144.         ;; change (sexpr) into ("/file" "/file2" ...)
  145.         ;; this assumes that there will never be (sexpr sexpr2)
  146.         ;; in a virtual folder spec.
  147.         (if (bufferp folder)
  148.         (if virtual
  149.             (setcar (car clauses)
  150.                 (delq nil
  151.                   (mapcar 'buffer-file-name vm-real-buffers)))
  152.           (if buffer-file-name
  153.               (setcar (car clauses) (list buffer-file-name)))))
  154.         ;; if new-messages non-nil use it instead of the
  155.         ;; whole message list
  156.         (setq mp (or new-messages vm-message-list))
  157.         (while mp
  158.           (if (and (not (intern-soft
  159.                  (vm-message-id-number-of
  160.                   (vm-real-message-of (car mp)))
  161.                  message-set))
  162.                (if virtual
  163.                (save-excursion
  164.                  (set-buffer
  165.                   (vm-buffer-of
  166.                    (vm-real-message-of
  167.                 (car mp))))
  168.                  (apply 'vm-vs-or (vm-real-message-of (car mp))
  169.                     selectors))
  170.              (apply 'vm-vs-or (car mp) selectors)))
  171.           (progn
  172.             (intern
  173.              (vm-message-id-number-of
  174.               (vm-real-message-of (car mp)))
  175.               message-set)
  176.             (setq message (copy-sequence
  177.                    (vm-real-message-of (car mp))))
  178.             (if mirrored
  179.             ()
  180.               (vm-set-mirror-data-of
  181.                message
  182.                (make-vector vm-mirror-data-vector-length nil))
  183.               (vm-set-virtual-messages-sym-of
  184.                message (make-symbol "<v>"))
  185.               (vm-set-virtual-messages-of message nil)
  186.               (vm-set-attributes-of
  187.                message
  188.                (make-vector vm-attributes-vector-length nil)))
  189.             (vm-set-location-data-of message location-vector)
  190.             (vm-set-softdata-of
  191.              message
  192.              (make-vector vm-softdata-vector-length nil))
  193.             (vm-set-real-message-sym-of
  194.              message
  195.              (vm-real-message-sym-of (car mp)))
  196.             (vm-set-message-type-of message vm-folder-type)
  197.             (vm-set-message-id-number-of message
  198.                          vm-message-id-number)
  199.             (vm-increment vm-message-id-number)
  200.             (vm-set-buffer-of message vbuffer)
  201.             (vm-set-reverse-link-sym-of message (make-symbol "<--"))
  202.             (vm-set-reverse-link-of message tail-cons)
  203.             (if (null tail-cons)
  204.             (setq new-message-list (list message)
  205.                   tail-cons new-message-list)
  206.               (setcdr tail-cons (list message))
  207.               (if (null new-message-list)
  208.               (setq new-message-list (cdr tail-cons)))
  209.               (setq tail-cons (cdr tail-cons)))))
  210.           (setq mp (cdr mp)))))
  211.       (setq folders (cdr folders)))
  212.     (setq clauses (cdr clauses))))
  213. ; this doesn't need to work currently, but it might someday
  214. ;    (if virtual
  215. ;    (setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
  216.     (vm-increment vm-modification-counter)
  217.     ;; Until this point the user doesn't really have a virtual
  218.     ;; folder, as the virtual messages haven't been linked to the
  219.     ;; real messages, virtual buffers to the real buffers, and no
  220.     ;; message list has been installed.
  221.     ;;
  222.     ;; Now we tie it all together, with this section of code being
  223.     ;; uninterruptible.
  224.     (let ((inhibit-quit t))
  225.       (if (null vm-real-buffers)
  226.       (setq vm-real-buffers real-buffers-used))
  227.       (save-excursion
  228.     (while real-buffers-used
  229.       (set-buffer (car real-buffers-used))
  230.       (if (not (memq vbuffer vm-virtual-buffers))
  231.           (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
  232.       (setq real-buffers-used (cdr real-buffers-used))))
  233.       (setq mp new-message-list)
  234.       (while mp
  235.     (vm-set-virtual-messages-of
  236.      (vm-real-message-of (car mp))
  237.      (cons (car mp) (vm-virtual-messages-of (car mp))))
  238.     (setq mp (cdr mp)))
  239.       (if vm-message-list
  240.       (progn
  241.         (vm-set-summary-redo-start-point new-message-list)
  242.         (vm-set-numbering-redo-start-point new-message-list))
  243.     (vm-set-summary-redo-start-point t)
  244.     (vm-set-numbering-redo-start-point t)
  245.     (setq vm-message-list new-message-list)))))
  246.  
  247. (defun vm-create-virtual-folder (selector &optional arg read-only)
  248.   "Create a new virtual folder from messages in the current folder.
  249. The messages will be chosen by applying the selector you specify,
  250. which is normally read from the minibuffer.
  251.  
  252. Prefix arg means the new virtual folder should be visited read only."
  253.   (interactive
  254.    (let ((last-command last-command)
  255.      (this-command this-command)
  256.      (prefix current-prefix-arg))
  257.      (vm-select-folder-buffer)
  258.      (nconc (vm-read-virtual-selector "Create virtual folder of messages: ")
  259.         (list prefix))))
  260.   (vm-select-folder-buffer)
  261.   (vm-check-for-killed-summary)
  262.   (vm-error-if-folder-empty)
  263.   (let (vm-virtual-folder-alist name)
  264.     (if arg
  265.     (setq name (format "%s %s %s" (buffer-name) selector arg))
  266.       (setq name (format "%s %s" (buffer-name) selector)))
  267.     (setq vm-virtual-folder-alist
  268.       (list
  269.        (list name
  270.          (list (list (list 'get-buffer (buffer-name)))
  271.                (if arg (list selector arg) (list selector))))))
  272.     (vm-visit-virtual-folder name read-only)))
  273.  
  274. (defun vm-apply-virtual-folder (name &optional read-only)
  275.   "Apply the selectors of a named virtual folder to the current folder
  276. and create a virtual folder containing the selected messages.
  277.  
  278. Prefix arg means the new virtual folder should be visited read only."
  279.   (interactive
  280.    (let ((last-command last-command)
  281.      (this-command this-command))
  282.      (list
  283.       (completing-read "Apply this virtual folder's selectors: "
  284.                vm-virtual-folder-alist nil t)
  285.       current-prefix-arg)))
  286.   (vm-select-folder-buffer)
  287.   (vm-check-for-killed-summary)
  288.   (vm-error-if-folder-empty)
  289.   (let ((vfolder (assoc name vm-virtual-folder-alist))
  290.     clauses vm-virtual-folder-alist)
  291.     (or vfolder (error "No such virtual folder, %s" name))
  292.     (setq vfolder (vm-copy vfolder))
  293.     (setq clauses (cdr vfolder))
  294.     (while clauses
  295.       (setcar (car clauses) (list (list 'get-buffer (buffer-name))))
  296.       (setq clauses (cdr clauses)))
  297.     (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder)))
  298.     (setq vm-virtual-folder-alist (list vfolder))
  299.     (vm-visit-virtual-folder (car vfolder) read-only)))
  300.  
  301. (defun vm-toggle-virtual-mirror ()
  302.   (interactive)
  303.   (vm-select-folder-buffer)
  304.   (vm-check-for-killed-summary)
  305.   (if (not (eq major-mode 'vm-virtual-mode))
  306.       (error "This is not a virtual folder."))
  307.   (let ((mp vm-message-list)
  308.     (inhibit-quit t)
  309.     modified undo-list)
  310.     (setq undo-list vm-saved-undo-record-list
  311.       vm-saved-undo-record-list vm-undo-record-list
  312.       vm-undo-record-list undo-list
  313.       vm-undo-record-pointer undo-list)
  314.     (setq modified vm-saved-buffer-modified-p
  315.       vm-saved-buffer-modified-p (buffer-modified-p))
  316.     (set-buffer-modified-p modified)
  317.     (if vm-virtual-mirror
  318.     (while mp
  319.       (vm-set-attributes-of
  320.        (car mp) (or (vm-saved-virtual-attributes-of (car mp))
  321.             (make-vector vm-attributes-vector-length nil)))
  322.       (vm-set-mirror-data-of
  323.        (car mp) (or (vm-saved-virtual-mirror-data-of (car mp))
  324.             (make-vector vm-mirror-data-vector-length nil)))
  325.       (vm-mark-for-summary-update (car mp) t)
  326.       (setq mp (cdr mp)))
  327.       (while mp
  328.     ;; mark for summary update _before_ we set this message to
  329.     ;; be mirrored.  this will prevent the real message and
  330.     ;; the other messages that will share attributes with
  331.     ;; this message from having their summaries
  332.     ;; updated... they don't need it.
  333.     (vm-mark-for-summary-update (car mp) t)
  334.     (vm-set-saved-virtual-attributes-of
  335.      (car mp) (vm-attributes-of (car mp)))
  336.     (vm-set-saved-virtual-mirror-data-of
  337.      (car mp) (vm-mirror-data-of (car mp)))
  338.     (vm-set-attributes-of
  339.      (car mp) (vm-attributes-of (vm-real-message-of (car mp))))
  340.     (vm-set-mirror-data-of
  341.      (car mp) (vm-mirror-data-of (vm-real-message-of (car mp))))
  342.     (setq mp (cdr mp))))
  343.     (setq vm-virtual-mirror (not vm-virtual-mirror))
  344.     (vm-increment vm-modification-counter))
  345.   (vm-update-summary-and-mode-line)
  346.   (message "Virtual folder now %s the underlying real folder%s."
  347.        (if vm-virtual-mirror "mirrors" "does not mirror")
  348.        (if (cdr vm-real-buffers) "s" "")))
  349.  
  350. (defun vm-virtual-help ()
  351.   (interactive)
  352.   (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help))
  353.   (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror"))
  354.  
  355. (defun vm-delete-directory-file-names (list)
  356.   (vm-delete 'file-directory-p list))
  357.  
  358. (defun vm-delete-backup-file-names (list)
  359.   (vm-delete 'backup-file-name-p list))
  360.  
  361. (defun vm-delete-auto-save-file-names (list)
  362.   (vm-delete 'auto-save-file-name-p list))
  363.  
  364. (defun vm-vs-or (m &rest selectors)
  365.   (let ((result nil) selector arglist)
  366.     (while selectors
  367.       (setq selector (car (car selectors))
  368.         arglist (cdr (car selectors))
  369.         result (apply (symbol-value selector) m arglist)
  370.         selectors (if result nil (cdr selectors))))
  371.     result ))
  372.  
  373. (defun vm-vs-and (m &rest selectors)
  374.   (let ((result t) selector arglist)
  375.     (while selectors
  376.       (setq selector (car (car selectors))
  377.         arglist (cdr (car selectors))
  378.         result (apply (symbol-value selector) m arglist)
  379.         selectors (if (null result) nil (cdr selectors))))
  380.     result ))
  381.  
  382. (defun vm-vs-not (m arg)
  383.   (let ((selector (car arg))
  384.     (arglist (cdr arg)))
  385.     (not (apply (symbol-value selector) m arglist))))
  386.  
  387. (defun vm-vs-any (m) t)
  388.  
  389. (defun vm-vs-author (m arg)
  390.   (or (string-match arg (vm-su-full-name m))
  391.       (string-match arg (vm-su-from m))))
  392.  
  393. (defun vm-vs-recipient (m arg)
  394.   (or (string-match arg (vm-su-to m))
  395.       (string-match arg (vm-su-to-names m))))
  396.  
  397. (defun vm-vs-subject (m arg)
  398.   (string-match arg (vm-su-subject m)))
  399.  
  400. (defun vm-vs-sent-before (m arg)
  401.   (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg)))
  402.  
  403. (defun vm-vs-sent-after (m arg)
  404.   (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m)))
  405.  
  406. (defun vm-vs-header (m arg)
  407.   (save-excursion
  408.     (save-restriction
  409.       (widen)
  410.       (goto-char (vm-headers-of m))
  411.       (re-search-forward arg (vm-text-of m) t))))
  412.  
  413. (defun vm-vs-label (m arg)
  414.   (vm-member arg (vm-labels-of m)))
  415.  
  416. (defun vm-vs-text (m arg)
  417.   (save-excursion
  418.     (save-restriction
  419.       (widen)
  420.       (goto-char (vm-text-of m))
  421.       (re-search-forward arg (vm-text-end-of m) t))))
  422.  
  423. (defun vm-vs-more-chars-than (m arg)
  424.   (> (string-to-int (vm-su-byte-count m)) arg))
  425.  
  426. (defun vm-vs-less-chars-than (m arg)
  427.   (< (string-to-int (vm-su-byte-count m)) arg))
  428.  
  429. (defun vm-vs-more-lines-than (m arg)
  430.   (> (string-to-int (vm-su-line-count m)) arg))
  431.  
  432. (defun vm-vs-less-lines-than (m arg)
  433.   (< (string-to-int (vm-su-line-count m)) arg))
  434.  
  435. (defun vm-vs-new (m) (vm-new-flag m))
  436. (defun vm-vs-unread (m) (vm-unread-flag m))
  437. (defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m))))
  438. (defun vm-vs-deleted (m) (vm-deleted-flag m))
  439. (defun vm-vs-replied (m) (vm-replied-flag m))
  440. (defun vm-vs-forwarded (m) (vm-forwarded-flag m))
  441. (defun vm-vs-filed (m) (vm-filed-flag m))
  442. (defun vm-vs-written (m) (vm-written-flag m))
  443. (defun vm-vs-marked (m) (vm-mark-of m))
  444. (defun vm-vs-edited (m) (vm-edited-flag m))
  445.  
  446. (put 'header 'vm-virtual-selector-clause "with header matching")
  447. (put 'label 'vm-virtual-selector-clause "with label of")
  448. (put 'text 'vm-virtual-selector-clause "with text matching")
  449. (put 'recipient 'vm-virtual-selector-clause "with recipient matching")
  450. (put 'author 'vm-virtual-selector-clause "with author matching")
  451. (put 'subject 'vm-virtual-selector-clause "with subject matching")
  452. (put 'sent-before 'vm-virtual-selector-clause "sent before")
  453. (put 'sent-after 'vm-virtual-selector-clause "sent after")
  454. (put 'more-chars-than 'vm-virtual-selector-clause
  455.      "with more characters than")
  456. (put 'less-chars-than 'vm-virtual-selector-clause
  457.      "with less characters than")
  458. (put 'more-lines-than 'vm-virtual-selector-clause "with more lines than")
  459. (put 'less-lines-than 'vm-virtual-selector-clause "with less lines than")
  460.  
  461. (defun vm-read-virtual-selector (prompt)
  462.   (let (selector (arg nil))
  463.     (setq selector
  464.       (vm-read-string prompt vm-supported-interactive-virtual-selectors)
  465.       selector (intern selector))
  466.     (if (memq selector '(header label text recipient
  467.              author subject
  468.              sent-before sent-after
  469.              more-chars-than more-lines-than
  470.              less-chars-than less-lines-than))
  471.     (progn
  472.       (setq prompt (concat (substring prompt 0 -2) " "
  473.                    (get selector 'vm-virtual-selector-clause)
  474.                    ": "))
  475.       (cond ((memq selector '(more-chars-than more-lines-than
  476.                       less-chars-than less-lines-than))
  477.          (setq arg (vm-read-number prompt)))
  478.         ((eq selector 'label)
  479.          (let ((vm-completion-auto-correct nil)
  480.                (completion-ignore-case t))
  481.            (setq arg (downcase
  482.                   (vm-read-string
  483.                    prompt
  484.                    (vm-obarray-to-string-list
  485.                 vm-label-obarray)
  486.                    nil)))))
  487.         (t (setq arg (read-string prompt))))))
  488.     (list selector arg)))
  489.  
  490. ;; clear away links between real and virtual folders when
  491. ;; a vm-quit is performed in either type folder.
  492. (defun vm-virtual-quit ()
  493.   (save-excursion
  494.     (cond ((eq major-mode 'vm-virtual-mode)
  495.        ;; don't trust blindly, user might have killed some of
  496.        ;; these buffers.
  497.        (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  498.        (let ((bp vm-real-buffers)
  499.          (mp vm-message-list)
  500.          (b (current-buffer))
  501.          ;; lock out interrupts here
  502.          (inhibit-quit t))
  503.          (while bp
  504.            (set-buffer (car bp))
  505.            (setq vm-virtual-buffers (delq b vm-virtual-buffers)
  506.              bp (cdr bp)))
  507.          (while mp
  508.            (vm-set-virtual-messages-of
  509.         (vm-real-message-of (car mp))
  510.         (delq (car mp) (vm-virtual-messages-of
  511.                 (vm-real-message-of (car mp)))))
  512.            (setq mp (cdr mp)))))
  513.       ((eq major-mode 'vm-mode)
  514.        ;; don't trust blindly, user might have killed some of
  515.        ;; these buffers.
  516.        (setq vm-virtual-buffers
  517.          (vm-delete 'buffer-name vm-virtual-buffers t))
  518.        (let ((bp vm-virtual-buffers)
  519.          (mp vm-message-list)
  520.          vmp
  521.          (b (current-buffer))
  522.          ;; lock out interrupts here
  523.          (inhibit-quit t))
  524.          (while mp
  525.            (setq vmp (vm-virtual-messages-of (car mp)))
  526.            (while vmp
  527.          ;; we'll clear these messages from the virtual
  528.          ;; folder by looking for messages that have a "Q"
  529.          ;; id number associated with them.
  530.          (vm-set-message-id-number-of (car vmp) "Q")
  531.          (setq vmp (cdr vmp)))
  532.            (vm-set-virtual-messages-of (car mp) nil)
  533.            (setq mp (cdr mp)))
  534.          (while bp
  535.            (set-buffer (car bp))
  536.            (setq vm-real-buffers (delq b vm-real-buffers))
  537.            ;; set the message pointer to a new value if it is
  538.            ;; now invalid.
  539.            (setq vmp vm-message-pointer)
  540.            (while (and vm-message-pointer
  541.                (equal "Q" (vm-message-id-number-of
  542.                        (car vm-message-pointer))))
  543.          (setq vm-message-pointer
  544.                (cdr vm-message-pointer)))
  545.            ;; if there were no good messages ahead, try going
  546.            ;; backward.
  547.            (if (null vm-message-pointer)
  548.            (progn
  549.              (setq vm-message-pointer vmp)
  550.              (while (and vm-message-pointer
  551.                  (equal "Q" (vm-message-id-number-of
  552.                          (car vm-message-pointer))))
  553.                (setq vm-message-pointer
  554.                  (vm-reverse-link-of (car vm-message-pointer))))))
  555.            ;; expunge the virtual messages associated with
  556.            ;; real messages that are going away.
  557.            (setq vm-message-list
  558.              (vm-delete (function
  559.                  (lambda (m)
  560.                    (equal "Q" (vm-message-id-number-of m))))
  561.                 vm-message-list nil))
  562.            (if (null vm-message-pointer)
  563.            (setq vm-message-pointer vm-message-list))
  564.            ;; same for vm-last-message-pointer
  565.            (if (null vm-last-message-pointer)
  566.            (setq vm-last-message-pointer nil))
  567.            (vm-clear-virtual-quit-invalidated-undos)
  568.            (vm-reverse-link-messages)
  569.            (vm-set-numbering-redo-start-point t)
  570.            (vm-set-summary-redo-start-point t)
  571.            (if vm-message-pointer
  572.            (vm-preview-current-message)
  573.          (vm-update-summary-and-mode-line))
  574.            (setq bp (cdr bp))))))))
  575.  
  576. (defun vm-virtual-save-folder (prefix)
  577.   (save-excursion
  578.     ;; don't trust blindly, user might have killed some of
  579.     ;; these buffers.
  580.     (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  581.     (let ((bp vm-real-buffers))
  582.       (while bp
  583.     (set-buffer (car bp))
  584.     (vm-save-folder prefix)
  585.     (setq bp (cdr bp)))))
  586.   (vm-set-buffer-modified-p nil)
  587.   (vm-clear-modification-flag-undos)
  588.   (vm-update-summary-and-mode-line))
  589.  
  590. (defun vm-virtual-get-new-mail ()
  591.   (save-excursion
  592.     ;; don't trust blindly, user might have killed some of
  593.     ;; these buffers.
  594.     (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  595.     (let ((bp vm-real-buffers))
  596.       (while bp
  597.     (set-buffer (car bp))
  598.     (condition-case error-data
  599.         (vm-get-new-mail)
  600.       (folder-read-only
  601.        (message "Folder is read only: %s"
  602.             (or buffer-file-name (buffer-name)))
  603.        (sit-for 1))
  604.       (unrecognized-folder-type
  605.        (message "Folder type is unrecognized: %s"
  606.             (or buffer-file-name (buffer-name)))
  607.        (sit-for 1)))
  608.     (setq bp (cdr bp)))))
  609.   (vm-emit-totals-blurb))
  610.  
  611. (defun vm-make-virtual-copy (m)
  612.   (widen)
  613.   (let ((virtual-buffer (current-buffer))
  614.     (real-m (vm-real-message-of m))
  615.     (buffer-read-only nil)
  616.     (modified (buffer-modified-p)))
  617.     (unwind-protect
  618.     (save-excursion
  619.       (set-buffer (vm-buffer-of real-m))
  620.       (save-restriction
  621.         (widen)
  622.         ;; must reference this now so that headers will be in
  623.         ;; their final position before the message is copied.
  624.         ;; otherwise the vheader offset computed below will be wrong.
  625.         (vm-vheaders-of real-m)
  626.         (copy-to-buffer virtual-buffer (vm-start-of real-m)
  627.                 (vm-end-of real-m))))
  628.       (set-buffer-modified-p modified))
  629.     (set-marker (vm-start-of m) (point-min))
  630.     (set-marker (vm-headers-of m) (+ (vm-start-of m)
  631.                      (- (vm-headers-of real-m)
  632.                     (vm-start-of real-m))))
  633.     (set-marker (vm-vheaders-of m) (+ (vm-start-of m)
  634.                       (- (vm-vheaders-of real-m)
  635.                      (vm-start-of real-m))))
  636.     (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m)
  637.                              (vm-start-of real-m))))
  638.     (set-marker (vm-text-end-of m) (+ (vm-start-of m)
  639.                       (- (vm-text-end-of real-m)
  640.                      (vm-start-of real-m))))
  641.     (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m)
  642.                             (vm-start-of real-m))))))
  643.